home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / test / checkans.fs < prev    next >
Encoding:
FORTH Source  |  1994-01-14  |  1.5 KB  |  59 lines
  1. \ CHECKANS.STR ANS Forth wordset checker                01may93jaw
  2.  
  3. \ 1-3MAY93 Jens A. Wilke
  4. \ This program is public domain
  5. \ Not for commercial usage!
  6.  
  7. DECIMAL
  8.  
  9. VARIABLE CharCount
  10. 30 CONSTANT MaxChars
  11. VARIABLE Flag
  12.  
  13. CREATE Names 500 ALLOT
  14. VARIABLE PNT Names PNT !
  15.  
  16. : INIT TRUE Flag ! 0 CharCount ! ;
  17.  
  18. : ^     PNT @ DUP @ 1+ SWAP !
  19.         BL WORD FIND
  20.         0= IF PNT @ CELL+ DUP @ 1+ SWAP !
  21.               Flag @ IF CR ." Missing: " FALSE Flag ! THEN
  22.               COUNT DUP CharCount +! TYPE SPACE
  23.               CharCount @ MaxChars U< 0= IF CR 9 SPACES 0 CharCount ! THEN
  24.            ELSE DROP THEN ;
  25.  
  26. : PLACE ( adr cnt adr -- ) 2DUP C! 1+ SWAP MOVE ;
  27.  
  28. : WS    INIT
  29.         PNT @ 2 CELLS + PNT !
  30.         BL WORD
  31.         CR CR ." Checking " DUP COUNT TYPE ."  wordset..."
  32.         DUP COUNT PNT @ PLACE COUNT SWAP DROP 1+
  33.         PNT @ + ALIGNED DUP PNT !
  34.         DUP 0 SWAP ! CELL+ 0 SWAP ! ;
  35.  
  36. S" wordsets.fs" INCLUDED
  37.  
  38. : END
  39.         CR CR ." Wordset:            Status:  Words:" CR
  40.  
  41.         Names 2 CELLS +
  42.         BEGIN
  43.                 DUP COUNT TYPE
  44.                 DUP COUNT SWAP DROP 20 SWAP - SPACES
  45.                 COUNT + ALIGNED
  46.                 DUP @ OVER CELL+ @
  47.                 2DUP 0=
  48.                 IF ." complete " . DROP DROP
  49.                 ELSE OVER =
  50.                  IF ." missing  " . DROP
  51.                  ELSE ." partial  " OVER SWAP - . ." / " .
  52.                  THEN
  53.                 THEN CR
  54.                 2 CELLS +
  55.                 DUP PNT @ U< 0=
  56.         UNTIL DROP ;
  57.  
  58. END
  59.